perm filename MIXSCR.F4[SCR,LCS]5 blob
sn#367631 filedate 1978-07-11 generic text, type T, neo UTF8
00100 C***** MIXES AND LINKS FILES PUT OUT BY 'SCORE' *******
00200 C***** ALL FILES MUST HAVE THE .SCR EXTENSION *****
00300 C***** LOAD WITH RENAM.FAI
00400 C***** USE 'R LOADER'. INCLUDE '/LLIB40.OLD[1,3]'. OTHERWISE THERE
00500 C WILL BE READ ERRORS DUE TO BUGS IN CURRENT LIB40 3/77 *******
00600
00700 COMMON /VV/Q(19),R(19),KL,N1,N2,N3,J,K,L,M,P1,PX,A,B,C,D,IBL
00800 COMMON /LNK/ NK,NZ(10),IP
00900 DATA IBL/' '/
01000 TYPE 24
01100 NK=0
01200 LX=0
01300 ACCEPT 2,K,IP
01400 IF(K.EQ.'L')LX=-1
01500 200 TYPE 20
01600 ACCEPT 2,N1
01700 IF(N1.EQ.IBL)GO TO 200
01800 IF(FINDIT(N1))CALL NOTFND(N1)
01900 C DO A LOOKUP FIRST OF ALL
02000 CC CALL RENAMX(N1,'SCR','$$$$1','DAT')
02100 201 TYPE 22
02200 ACCEPT 2,N2
02300 IF(N2.EQ.IBL.OR.N2.EQ.N1)GO TO 201
02400 IF(FINDIT(N2))CALL NOTFND(N2)
02500 IF(LX.EQ.0)GO TO 202
02600 1000 TYPE 41
02700 ACCEPT 2,K
02800 IF(K.EQ.IBL)GO TO 202
02900 C TAKES UP TO 2+10 FILES.
03000 NK=NK+1
03100 NZ(NK)=K
03200 IF(NK.LT.10)GO TO 1000
03300
03400 202 TYPE 23
03500 ACCEPT 2,N3
03600 IF(N3.EQ.IBL)GO TO 202
03700 CALL OFILE(1,N3)
03800 TYPE 300
03900 300 FORMAT(' ****** CAUTION ******'/
04000 1' ****** NEVER STOP THIS PROGRAM WHILE IT IS WORKING ******'/)
04100 CALL RENAMX(N1,'SCR','$$$$1','DAT')
04200 CALL RENAMX(N2,'SCR','$$$$2','DAT')
04300 CALL IFILE(21,'$$$$1')
04400 CALL IFILE(22,'$$$$2')
04500 TYPE 25
04600 IF(LX.EQ.0)GO TO 25
04700 CALL LINK
04800 GO TO 204
04900 25 FORMAT(/' WORKING'/)
05000 DO 1 K=1,3
05100 READ(21,2)Q
05200 WRITE(1,2)Q
05300 1 READ(22,2)Q
05400 C READS FIRST 3 LINES
05500
05600 CALL CHECK(N,Q,P1,21)
05700 CALL CHECK(M,R,PX,22)
05800 CATCHES INSERTED LINES.
05900 6 IF(PX.LT.P1)GO TO 5
06000 CALL RDWRT(N,P1,Q,21)
06100 IF(KL)10,6,6
06200
06300 5 CALL RDWRT(M,PX,R,22)
06400 IF(KL.EQ.0)GO TO 6
06500
06600 11 PX=10000
06700 GO TO 13
06800 10 P1=10000
06900 13 IF(P1.NE.10000.OR.M.NE.N)GO TO 6
07000 CC13 IF(P1.NE.10000.AND.M.NE.N)GO TO 6
07100 12 WRITE(1,7)
07200 REWIND 21
07300 REWIND 22
07400 CALL RENAMX('$$$$1','DAT',N1,'SCR')
07500 CALL RENAMX('$$$$2','DAT',N2,'SCR')
07600 204 END FILE 1
07700 CALL RENAM(N3,'DAT',N3,'SCR')
07800 TYPE 203,N3
07900 CALL EXIT
08000 203 FORMAT(/' ****** MIX FILE NAME = ',A5,'.SCR')
08100 2 FORMAT(19A5)
08200 7 FORMAT(' FINISH;')
08300 24 FORMAT(' MIXES OR LINKS SCORE LISTS.'/
08400 1' USES ".SCR" EXTENSIONS ONLY!!! '/
08500 1' BE SURE ALL HIGHER PARAMS PRINT EACH TIME.'
08600 1//' L = LINK, <CR> = MIX '$)
08700 41 FORMAT(' TYPE NEXT FILE NAME OR <CR> '$)
08800 20 FORMAT(' TYPE FILE 1 (WITHOUT EXT.) '$)
08900 22 FORMAT(/' TYPE FILE 2 '$)
09000 23 FORMAT(/' TYPE OUTPUT NAME '$)
09100 END
09200
09300 SUBROUTINE CHECK(N,Q,P1,J)
09400 COMMON /VV/QQ(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,IBL
09500 DIMENSION Q(19),AA(50)
09550 DATA J1/4/,J2/9/,J3/18/
09575 C J1,J2,J3 ARE POINTERS TO POS. OF DOTS IN P1,P2
09600 KL=0
09700 33 READ(J,30,END=100)L,N,K,Q,AA
09800 IF(Q(J1).NE.' ')GO TO 32
09900 IF(Q(J2).NE.'.')GO TO 32
10000 IF(Q(J3).EQ.'.')GO TO 31
10100 CATCHES INSERTED LINES.
10200 32 REREAD 44,L,N,Q
10300 IF(N.EQ.'FINIS')KL=-1
10400 CALL SHORT(Q,N)
10500 CC TYPE 44,L,N,(Q(LL),LL=1,K)
10600 IF(KL)RETURN
10700 CC WRITE(1,44)L,N,(Q(LL),LL=1,K)
10800 GO TO 33
10900 100 PAUSE 'DIED IN SUBR CHECK'
11000 31 REREAD 4,L,N,P1
11100 REREAD 44,L,N,Q
11200 30 FORMAT(72A1)
11300 4 FORMAT(A1,A5,F)
11400 44 FORMAT(A1,20A5)
11500 END
11600
11700 SUBROUTINE SHORT(Q,N)
11800 COMMON /VV/QQ(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,A,B,IBL
11900 COMMON /LNK/ NK,NZ(10),IP
12000 DIMENSION Q(1)
12200 DO 1 K=19,1,-1
12300 1 IF(Q(K).NE.' ')GO TO 2
12400 2 IF(IP.NE.IBL)TYPE 44,L,N,(Q(LL),LL=1,K)
12500 IF(KL)RETURN
12600 WRITE(1,44)L,N,(Q(LL),LL=1,K)
12700 44 FORMAT(A1,20A5)
12800 END
12900
13000 SUBROUTINE RDWRT(I,P,R,J)
13100 COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
13200 DIMENSION R(19)
13300 KL=0
13400 CALL SHORT(R,I)
13500 CC WRITE(1,44)L,I,(R(N),N=1,K)
13600 CC TYPE 44,L,I,(R(N),N=1,K)
13700 1 READ (J,44,END=100)L,I,R
13800 CXX REREAD 44,L,I,R
13900 CALL SHORT(R,I)
14000 CC WRITE(1,44)L,I,(R(N),N=1,K)
14100 CC TYPE 44,L,I,(R(N),N=1,K)
14200 IF(I.NE.'PRINT')GO TO 1
14300 2 CALL CHECK(I,R,P,J)
14400 RETURN
14500 44 FORMAT(A1,20A5)
14600 100 PAUSE 'DIED IN SUBR RDWRT'
14700 END
14800
14900 SUBROUTINE LINK
15000 COMMON /VV/Q(19),RR(19),KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
15100 COMMON /LNK/ NK,NZ(10),IP
15200 44 FORMAT(A1,20A5)
15300 KL=0
15400 JJ=0
15500 J=21
15600 1 READ(J,44)L,LL,Q
15700 IF(LL.EQ.'FINIS')GO TO 2
15800 4 CALL SHORT(Q,LL)
15900 IF(JJ.GT.NK)RETURN
16000 GO TO 1
16100 2 IF(J.NE.21)GO TO 3
16200 REWIND 21
16300 CALL RENAMX('$$$$1','DAT',N1,'SCR')
16400 J=J+1
16500 GO TO 1
16600 3 REWIND 22
16700 IF(JJ.NE.0)GO TO 6
16800 CALL RENAMX('$$$$2','DAT',N2,'SCR')
16900 GO TO 5
17000 6 CALL RENAMX('$$$$2','DAT',NZ(JJ),'SCR')
17100 5 JJ=JJ+1
17200 IF(JJ.GT.NK)GO TO 4
17300 CALL RENAMX(NZ(JJ),'SCR','$$$$2','DAT')
17400 CALL IFILE(22,'$$$$2')
17500 GO TO 1
17600 END
17700
17800 SUBROUTINE RENAMX(J,K,L,M)
17900 CALL RENAM(J,K,L,M)
18000 TYPE 1,J,K,L,M
18100 1 FORMAT(' (RENAME -- ',A5,'.',A3,' CHANGED TO -- ',A5,'.',A3,')')
18200 END
18300
18400 SUBROUTINE NOTFND(NM)
18500 TYPE 1,NM
18600 CALL EXIT
18700 1 FORMAT(' ******* FILE ',A5,'.SCR NOT FOUND *****')
18800 END